perm filename FREEU[900,BGB] blob
sn#129573 filedate 1974-11-11 generic text, type T, neo UTF8
(SETQ IBASE (ADD1 9))
(DEFPROP ALLFNS
(NIL DOALL
ZXC
FETCH
STORBILL
RESET
BANK
DELETC
PRDEBIT
PRCREDIT
PRCHK
PR$
PRDATE
MON
DATEL
GDGT2
REASON
MONTH
BTOTAL
CTOTAL
DELCHK
SAFE
INCHECKS)
VALUE)
(DEFPROP DOALL
(LAMBDA NIL
(PROG NIL
(RESET)
(LPTOUT (BANK BSTATE1))
(LPTOUT (BANK BSTATE2))
(LPTOUT (BANK BSTATE3))
(LPTOUT (BANK BSTATE4))
(LPTOUT (BANK BSTATE5))
(SETQ QWE (LIST CC DB))
(LPTOUT (GRINL QWE))
(RETURN (QUOTE "ALL DONE"))))
EXPR)
(DEFPROP ZXC
(NIL (134 :4:6 JAYSN 18000 RENT)
(138 :4:23 PGE 4759 OFFIC)
(140 :4:23 CALWS 420 OFFIC)
(143 :4:30 DOCEY 15000 PAY)
(154 :5:15 JAYSN 18000 RENT)
(159 :5:18 SMCSC 1200 OFFIC)
(166 :5:25 PGE 4650 OFFIC)
(167 :5:25 CALWS 420 OFFIC)
(169 :5:31 DOCEY 20000 PAYROLL)
(176 :6:4:69 JAYSN 18000 RENT))
VALUE)
(DEFPROP FETCH
(LAMBDA(N)
(PROG (Z)
(SETQ Z CHECKS)
L (COND ((NULL Z) (RETURN NIL)) ((EQUAL (CAAR Z) N) (RETURN (CAR Z))))
(SETQ Z (CDR Z))
(GO L)))
EXPR)
(DEFPROP STORBILL
(LAMBDA(ZZ)
(PROG (Z N X DAY WHO)
(SETQ Z ZZ)
(SETQ N 0)
(PRINC (QUOTE " STORE OWES MAIN ACCOUNT: "))
(TERPRI)
L (SETQ X (CAR (CDDDAR Z)))
(SETQ DAY (CADAR Z))
(SETQ WHO (CADDAR Z))
(COND ((EQUAL WHO (QUOTE DOCEY)) (COND ((EQUAL X 20000) (SETQ X 22490)) (T (SETQ X 16280))))
(T (SETQ X (QUOTIENT X 2))))
(PR$ X)
(PRDATE DAY)
(PRINC (QUOTE " FOR "))
(PRINC (CDR (ASSOC WHO ABBREV)))
(TERPRI)
(SETQ N (PLUS N X))
(COND ((NOT (NULL (SETQ Z (CDR Z)))) (GO L)))
(TERPRI)
(PRINC (QUOTE " TOTAL DUE "))
(PR$ N)
(TERPRI)))
EXPR)
(DEFPROP RESET
(LAMBDA NIL
(PROG NIL
(SETQ CC CHECKS)
(SETQ DP (APPEND DJAN DFEB DMAR DAPR DMAY))
(SETQ DB DEBITS)
(RETURN (QUOTE "OK"))))
EXPR)
(DEFPROP BANK
(LAMBDA(ZZ)
(PROG (DATE N X Y Z INS OUTS)
(PRINC (QUOTE " BANK STATEMENT FOR PERIOD FROM "))
(PRDATE (CAADR ZZ))
(PRINC (QUOTE " TO "))
(PRDATE (CAAR ZZ))
(TERPRI)
(PRINC (QUOTE "BEGINNING BALANCE "))
(PR$ (CAR (CDDDAR ZZ)))
(TERPRI)
(PRINC (QUOTE "ENDING BALANCE "))
(PR$ (CADR (CDDDAR ZZ)))
(TERPRI)
(TERPRI)
(PRINC (QUOTE " BANK STATEMENT CHECK LEDGER"))
(TERPRI)
(SETQ OUTS 0)
(SETQ INS 0)
(SETQ Z (CDR ZZ))
L1 (COND
((NULL Z)
(PROG2 (PROG NIL
(TERPRI)
(PRINC (QUOTE " INPUT "))
(PR$ INS)
(TERPRI)
(PRINC (QUOTE "OUTPUT "))
(PR$ OUTS)
(TERPRI)
(PRINC (QUOTE " DELTA "))
(PR$ (PLUS INS OUTS))
(TERPRI)
(PRINC (QUOTE " ERROR "))
(PR$ (PLUS (CAR (CDDDAR ZZ)) INS OUTS (MINUS (CADR (CDDDAR ZZ)))))
(TERPRI))
(RETURN NIL))))
(SETQ DATE (CAAR Z))
(SETQ Y (CDAR Z))
L2 (COND ((NULL Y) (GO L3)))
(SETQ X (CAR Y))
(COND ((MINUSP X) (SETQ OUTS (PLUS OUTS X))) (T (SETQ INS (PLUS INS X))))
(COND ((NOT (MINUSP X)) (PRCREDIT X DATE DP))
((NOT (SETQ N (PRCHK X DATE CC))) (SETQ DB (PRDEBIT X DATE DB))))
(TERPRI)
(COND ((NUMBERP N) (SETQ CC (DELETC N CC))))
(SETQ Y (CDR Y))
(GO L2)
L3 (SETQ Z (CDR Z))
(GO L1)))
EXPR)
(DEFPROP DELETC
(LAMBDA(N ZZ)
(PROG (Z Q)
(SETQ Q NIL)
(SETQ Z ZZ)
L (COND ((NULL Z) (RETURN ZZ)) ((EQ (CAAR Z) N) (RETURN (APPEND Q (CDR Z)))))
(SETQ Q (APPEND Q (LIST (CAR Z))))
(SETQ Z (CDR Z))
(GO L)))
EXPR)
(DEFPROP PRDEBIT
(LAMBDA(X DATE DDD)
(PROG (Z Q)
(SETQ Q NIL)
(SETQ Z DDD)
L (COND
((NULL Z) (PR$ X)
(PRDATE DATE)
(PRINC (QUOTE "** *** **** DEBIT UNACCOUNTED FOR **** *** **"))
(RETURN DDD)))
(COND
((AND (EQUAL (CADAR Z) (MINUS X)) (DATEL (CAAR Z) DATE)) (PR$ X)
(PRDATE DATE)
(PRDATE (CAAR Z))
(PRINC (QUOTE "*** BANK-DEBIT "))
(PRINC (CADDAR Z))
(PRINC (QUOTE " "))
(PRINC
(PROG2 (SETQ X
(ASSOC
(CADDDR (CAR Z))
REASON))
(COND (X (CDR X)) (T NIL))))
(RETURN (APPEND Q (CDR Z)))))
(SETQ Q (APPEND Q (NCONS (CAR Z))))
(SETQ Z (CDR Z))
(GO L)))
EXPR)
(DEFPROP PRCREDIT
(LAMBDA(X DATE DXXX)
(PROG (Z D Y)
(SETQ Z DXXX)
L1 (COND ((NULL Z) (PR$ X) (PRDATE DATE) (PRINC (QUOTE " DEPOSIT RECEIPT NOT FOUND ")) (RETURN NIL)))
(SETQ Y (CDAR Z))
L2 (COND ((NULL Y) (GO L3)))
(SETQ D (CAAR Z))
(COND
((AND (EQUAL X (CAR Y)) (DATEL D DATE)) (PR$ X)
(PRDATE DATE)
(PRDATE D)
(PRINC (QUOTE " RECEIPT"))
(RETURN T)))
(SETQ Y (CDR Y))
(GO L2)
L3 (SETQ Z (CDR Z))
(GO L1)))
EXPR)
(DEFPROP PRCHK
(LAMBDA(X DATE Z)
(PROG (ZZ)
(SETQ ZZ Z)
L (COND ((NULL ZZ) (RETURN NIL)))
(COND
((AND (EQUAL (MINUS X) (CAR (CDDDAR ZZ))) (DATEL (CADAR ZZ) DATE)) (PR$ X)
(PRDATE DATE)
(PRDATE (CADAR ZZ))
(PRINC (CAAR ZZ))
(PRINC (QUOTE " "))
(PRINC
(PROG2 (SETQ X
(ASSOC
(CADDAR ZZ)
ABBREV))
(COND
(X (CDR X))
(T (CADDAR ZZ)))))
(PRINC (QUOTE " "))
(PRINC (QUOTE " FOR "))
(PRINC (CADR (CDDDAR ZZ)))
(RETURN (CAAR ZZ))))
(SETQ ZZ (CDR ZZ))
(GO L)))
EXPR)
(DEFPROP PR$
(LAMBDA(ZZ)
(PROG (Z Z1 Z2 Z3)
(SETQ Z (COND ((MINUSP ZZ) (MINUS ZZ)) (T ZZ)))
(SETQ Z1 (QUOTIENT Z 100000))
(SETQ Z2 (DIFFERENCE (QUOTIENT Z 100) (TIMES Z1 1000)))
(SETQ Z3 (REMAINDER Z 100))
(COND ((ZEROP Z1) (PRINC (QUOTE " ")))
((GREATERP 10 Z1) (PRINC (QUOTE " ")) (PRINC Z1) (PRINC (QUOTE ",")))
(T (PRINC (QUOTE " ")) (PRINC Z1) (PRINC (QUOTE ","))))
(COND ((GREATERP 10 Z2) (PRINC (COND ((ZEROP Z1) (QUOTE " ")) (T (QUOTE "00"))))
(PRINC Z2)
(PRINC (QUOTE ".")))
((GREATERP 100 Z2) (PRINC (COND ((ZEROP Z1) (QUOTE " ")) (T 0))) (PRINC Z2) (PRINC (QUOTE ".")))
(T (PRINC Z2) (PRINC (QUOTE "."))))
(COND ((GREATERP 10 Z3) (PRINC 0)))
(PRINC Z3)
(PRINC (COND ((MINUSP ZZ) (QUOTE "- ")) (T (QUOTE " "))))))
EXPR)
(DEFPROP PRDATE
(LAMBDA(Z)
(PROG (Z1 Z2)
(SETQ Z1 (GDGT2 (CDR (EXPLODE Z)) 0))
(SETQ Z2 (CAR (GDGT2 (CDR Z1) 0)))
(SETQ Z1 (CAR Z1))
(COND ((GREATERP 10 Z2) (PRINC (QUOTE " "))))
(PRINC Z2)
(PRINC (QUOTE " "))
(PRINC (CADR (ASSOC Z1 MON)))
(PRINC (QUOTE " 1969 "))))
EXPR)
(DEFPROP MON
(NIL (1 JAN) (2 FEB) (3 MAR) (4 APR) (5 MAY) (6 JUN) (7 JUL) (8 AUG) (9 SPT) (10 OCT) (11 OCT) (12 DEC))
VALUE)
(DEFPROP DATEL
(LAMBDA(A B)
(PROG (Z1 Z2 Z3 Z4)
(SETQ Z1 (GDGT2 (CDR (EXPLODE A)) 0))
(SETQ Z2 (GDGT2 (CDR (EXPLODE B)) 0))
(SETQ Z3 (GDGT2 (CDR Z1) 0))
(SETQ Z4 (GDGT2 (CDR Z2) 0))
(RETURN
(OR (NOT (GREATERP (CAR Z1) (CAR Z2)))
(AND (EQ (CAR Z1) (CAR Z2)) (NOT (GREATERP (CAR Z3) (CAR Z4))))))))
EXPR)
(DEFPROP GDGT2
(LAMBDA(Z N)
(COND ((NULL Z) (NCONS N))
((EQ (CAR Z) (QUOTE :)) (CONS N (CDR Z)))
(T (GDGT2 (CDR Z) (PLUS (TIMES 10 N) (CAR Z))))))
EXPR)
(DEFPROP REASON
(NIL (A REFER TO MAKER)
(B ENDORSEMENT MISSING)
(C CANNOT LOCATE ACCOUNT)
(D SIGNATURE MISSING)
(E POST DATED)
(F UNCOLLECTED FUNDS)
(G INSUFFICIENT FUNDS)
(H PAYMENT STOPPED)
(I ACCOUNT CLOSED)
(J STALE DATE))
VALUE)
(DEFPROP MONTH
(NIL (1 JANUARY)
(2 FEBRUARY)
(3 MARCH)
(4 APRIL)
(5 MAY)
(6 JUNE)
(7 JULY)
(8 AUGUST)
(9 SEPTDMBER)
(10 OCTOBER)
(11 NOVEMBER)
(12 DECEMBER))
VALUE)
(DEFPROP BTOTAL
(LAMBDA(Z)
(PROG (N ZZ)
(SETQ N 0)
(SETQ ZZ Z)
L (COND ((NULL ZZ) (RETURN N)))
(SETQ N (PLUS N (EVAL (CONS (QUOTE PLUS) (CDAR ZZ)))))
(SETQ ZZ (CDR ZZ))
(GO L)))
EXPR)
(DEFPROP CTOTAL
(LAMBDA(Z)
(PROG (ZZ N)
(SETQ ZZ Z)
(SETQ N 0)
L (COND ((NULL ZZ) (RETURN N)))
(SETQ N (PLUS (CAR (CDDDAR ZZ)) N))
(SETQ ZZ (CDR ZZ))
(GO L)))
EXPR)
(DEFPROP DELCHK
(LAMBDA NIL (PROG2 (SETQ CHECKS (CDR CHECKS)) (CAAR CHECKS)))
EXPR)
(DEFPROP SAFE
(LAMBDA NIL (DSKOUT FREEU (GRINL ALLFNS)))
EXPR)
(DEFPROP INCHECKS
(LAMBDA NIL
(PROG (A B C D E)
L (PRINC (QUOTE "# "))
(SETQ A (READ))
(PRINC (QUOTE "DAY "))
(SETQ B (READ))
(PRINC (QUOTE "TO "))
(SETQ C (READ))
(PRINC (QUOTE "$ "))
(SETQ D (READ))
(PRINC (QUOTE "FOR "))
(SETQ E (READ))
(COND ((ZEROP A) (RETURN NIL)))
(SETQ CHECKS (CONS (LIST A B C D E) CHECKS))
(GO L)))
EXPR)